Your Choice 3/Your Choice Software Collection 3.iso/prgmming/pcl4pb42/xymodem.bas

BASIC Source File | 1994-10-03 | 11KB | 443 lines

' -- XYMODEM.BAS --
'
' This program is donated to the Public
' Domain by MarshallSoft Computing, Inc.
' It is provided as an example of the use
' of the Personal Communications Library.
'
$CPU 8086          'make compatible with XT systems
$LIB ALL OFF       'turn off all PowerBASIC libraries
$ERROR ALL ON      'turn on all PowerBASIC error checking
$OPTIMIZE SIZE     'optimize for smaller code
$COMPILE UNIT      'compile to a UNIT (.PBU)

DEFINT A-Z         'Required for all numeric functions, forces PB to not
                   'include floating point routines in UNIT (makes it smaller)

$INCLUDE "PCL4PB.BI"
$INCLUDE "TERM_IO.BI"
$INCLUDE "XYPACKET.BI"

%NAK   = &H15
%CAN   = &H18
%FALSE = 0
%TRUE  = NOT %FALSE

DEFINT A-Z

FUNCTION FetchName(Filename AS STRING) PUBLIC

  FetchName = %TRUE
  IF LEN(Filename$) = 0 THEN
    WriteMsg "Enter filename: ", 1
    ReadMsg Filename$, 16, 20
    IF LEN(Filename) = 0 THEN
      FetchName = %FALSE
    END IF
  END IF

END FUNCTION

FUNCTION RxyModem(BYVAL Port      AS INTEGER, _
                        Filename  AS STRING,  _
                  BYVAL NCGbyte   AS BYTE,    _
                  BYVAL BatchFlag AS INTEGER) PUBLIC

  ON LOCAL ERROR GOTO RxyTrap

  DIM Buffer(1024) AS BYTE
  DIM TheByte      AS BYTE
  DIM BufferSize   AS INTEGER
  DIM ErrorFlag    AS INTEGER
  DIM EOTflag      AS INTEGER
  DIM FirstPacket  AS INTEGER
  DIM Code         AS INTEGER
  DIM FileNbr      AS INTEGER
  DIM Packet       AS INTEGER
  DIM PacketNbr    AS INTEGER
  DIM I            AS INTEGER
  DIM Flag         AS INTEGER
  DIM FileBytes    AS LONG
  DIM AnyKey       AS STRING
  DIM Message      AS STRING
  DIM Temp         AS STRING

  ErrorFlag = %FALSE
  EOTflag   = %FALSE

  WriteMsg "XYMODEM Receive: Waiting for Sender ", 1

  'clear comm port
  Code = SioRxFlush(Port)

  'Send NAKs or 'C's
  IF NOT RxStartup(Port, NCGbyte) THEN
    RxyModem = %FALSE
    EXIT FUNCTION
  END IF

  'open file unless BatchFlag is on
  IF BatchFlag THEN
    FirstPacket = 0
  ELSE
    FirstPacket = 1
    'Open file for write
    FileNbr = FREEFILE
    OPEN Filename$ FOR BINARY ACCESS WRITE AS FileNbr
    PRINT "Opening "; Filename$
  END IF

  'get each packet in turn
  FOR Packet = FirstPacket TO 32767
    'user aborts ?
    AnyKey$ = INKEY$
    IF AnyKey$ = STR$(%CAN) THEN
      CALL TxCAN(Port)
      CALL WriteMsg("*** Canceled by USER ***", 1)
      RxyModem = %FALSE
      EXIT FUNCTION
    END IF
    'issue message
    Message$ = "Packet " + STR$(Packet)
    CALL WriteMsg(Message$, 1)
    PacketNbr = Packet AND 255
    'get next packet
    IF NOT RxPacket(Port, Packet, Buffer(), BufferSize, NCGbyte, EOTflag) THEN
      RxyModem = %FALSE
      EXIT FUNCTION
    END IF
    'packet 0 ?
    IF Packet = 0 THEN
      'name & date packet
      IF Buffer(0) = 0 THEN
        CALL WriteMsg("Batch transfer complete", 1)
        RxyModem = %TRUE
        EXIT FUNCTION
      END IF
      'construct filename
      I = 0
      Filename$ = ""
      DO
        TheByte = Buffer(I)
        IF TheByte = 0 THEN
          EXIT DO
        END IF
        Filename$ = Filename$ + CHR$(TheByte)
        I = I + 1
      LOOP
      'get file size
      I = I + 1
      Temp$ = ""
      DO
        TheByte = Buffer(I)
        IF TheByte = 0 THEN
          EXIT DO
        END IF
        Temp$ = Temp$ + CHR$(TheByte)
        I = I + 1
      LOOP
      FileBytes = VAL(Temp$)
    END IF
    'all done if EOT was received
    IF EOTflag THEN
      CLOSE FileNbr
      CALL WriteMsg("Transfer completed", 1)
      RxyModem = %TRUE
      EXIT FUNCTION
    END IF
    'process the packet
    IF Packet = 0 THEN
      'open file using filename in packet 0
      FileNbr = FREEFILE
      OPEN Filename$ FOR BINARY ACCESS WRITE AS FileNbr
      PRINT "Opening "; Filename$
      'must restart after packet 0
      Flag = RxStartup(Port, NCGbyte)
    ELSE
      'Packet > 0  ==> write Buffer
      FOR I = 0 TO BufferSize-1
        PUT FileNbr, , Buffer(I)
      NEXT I
    END IF
  NEXT Packet

  CLOSE FileNbr
  EXIT FUNCTION

RxyTrap:
  SELECT CASE ERR
    CASE 53
      Message$ = "Cannot open " + Filename$ + " for write"
      CALL WriteMsg(Message$, 1)
    CASE ELSE
      PRINT "RX Error: "; "(ERROR$)" ; " ("; ERR; ")"
    END SELECT

    RxyModem = %FALSE
    EXIT FUNCTION

END FUNCTION

FUNCTION TxyModem(BYVAL Port      AS INTEGER, _
                        Filename  AS STRING,  _
                  BYVAL OneKflag  AS INTEGER, _
                  BYVAL BatchFlag AS INTEGER) PUBLIC
  ON LOCAL ERROR GOTO TxyTrap

  DIM Buffer(1024)   AS BYTE
  DIM NCGbyte        AS BYTE
  DIM TheByte        AS BYTE
  DIM BufferSize     AS INTEGER
  DIM ErrorFlag      AS INTEGER
  DIM EOTflag        AS INTEGER
  DIM FirstPacket    AS INTEGER
  DIM Code           AS INTEGER
  DIM FileNbr        AS INTEGER
  DIM Packet         AS INTEGER
  DIM PacketNbr      AS INTEGER
  DIM ReadSize       AS INTEGER
  DIM I              AS INTEGER
  DIM K              AS INTEGER
  DIM L              AS INTEGER
  DIM EmptyFlag      AS INTEGER
  DIM Flag           AS INTEGER
  DIM BlockSize      AS INTEGER
  DIM Number128      AS WORD
  DIM Number1K       AS WORD
  DIM FileBytes      AS LONG
  DIM RemainingBytes AS LONG
  DIM AnyKey         AS STRING
  DIM Message        AS STRING
  DIM Temp           AS STRING

  Number128 = 0
  Number1K  = 0
  NCGbyte   = %NAK
  EOTflag   = %FALSE
  EmptyFlag = %FALSE

  IF BatchFlag THEN
    IF LEN(Filename$) = 0 THEN
      EmptyFlag = %TRUE
    END IF
  END IF
  IF NOT EmptyFlag THEN
    FileNbr = FREEFILE
    OPEN Filename$ FOR BINARY ACCESS READ AS FileNbr
    PRINT "Opening "; Filename$
  END IF
  WriteMsg "XYMODEM: waiting for receiver ", 1

  'compute # blocks
  IF EmptyFlag THEN
    'empty file
    Number128 = 0
    Number1K = 0
  ELSE
    'filename is not empty. compute file length
    FileBytes = LOF(FileNbr)
    RemainingBytes = FileBytes
    IF OneKflag THEN
      Number1K = FileBytes \ 1024
    ELSE
      Number1K = 0
    END IF
    Number128 = (FileBytes - 1024 * Number1K) \ 128
    IF (128 * Number128 + 1024 * Number1K) < FileBytes THEN
      Number128 = Number128 + 1
    END IF
    Message$ = STR$(Number1K) + " 1K & " + STR$(Number128) + " 128-byte packets"
    WriteMsg Message$, 1
    PRINT Message$
  END IF

  'clear comm port (there may be several NAKs queued up)
  Code = SioRxFlush(Port)

  'get receivers start up NAK or 'C'
  IF NOT TxStartup(Port, NCGbyte) THEN
    TxyModem = %FALSE
    EXIT FUNCTION
  END IF

  'loop over all packets
  IF BatchFlag THEN
    FirstPacket = 0
  ELSE
    FirstPacket = 1
  END IF

  'transmit each packet in turn
  FOR Packet = FirstPacket TO Number1K + Number128
    'user aborts ?
    AnyKey$ = INKEY$
    IF AnyKey$ = STR$(%CAN) THEN
      CALL TxCAN(Port)
      CALL WriteMsg("*** Canceled by USER ***", 1)
      TxyModem = %FALSE
      EXIT FUNCTION
    END IF
    'issue message
    Message$ = "Packet " + STR$(Packet)
    CALL WriteMsg(Message$, 1)
    'load up internal buffer
    IF Packet = 0 THEN
      'packet = 0. Init Buffer to 128 zeros.
      BlockSize = 128
      FOR I = 0 TO 127
        Buffer(I) = 0
      NEXT I
      IF EmptyFlag THEN
        'send empty buffer
      ELSE
        'not empty: copy filename to buffer
        K = 0
        L = LEN(Filename$)
        FOR I = 1 TO L
          Buffer(K) = ASC(MID$(Filename$,I,1))
          K = K + 1
        NEXT I
        'copy file length to buffer
        Temp$ = STR$(FileBytes)
        L = LEN(Temp$)
        K = K + 1
        FOR I = 1 TO L
          Buffer(K) = ASC(MID$(Temp$,I,1))
          K = K + 1
        NEXT I
      END IF
    ELSE
      'DATA Packet: use 1K or 128-byte blocks ?
      IF BatchFlag AND (Packet <= Number1K) THEN
        BlockSize = 1024
      ELSE
        BlockSize = 128
      END IF
      'compute # bytes to read
      IF RemainingBytes < BlockSize THEN
        ReadSize = RemainingBytes
      ELSE
        ReadSize = BlockSize
      END IF
      'read next block from disk
      FOR I = 0 TO ReadSize-1
        GET FileNbr, , Buffer(I)
      NEXT I
      RemainingBytes = RemainingBytes - ReadSize
      'pad short buffer with ^Z
      IF ReadSize < BlockSize THEN
        FOR I = ReadSize TO BlockSize-1
          Buffer(I) = &H1A
        NEXT I
      END IF
    END IF
    'Send this packet
    IF NOT TxPacket(Port, Packet, Buffer(), BlockSize, NCGbyte) THEN
      TxyModem = %FALSE
      EXIT FUNCTION
    END IF
    Code = SioDelay(5)
    'must 'restart' after non null packet 0
    IF (NOT EmptyFlag) AND (Packet = 0) THEN
      Flag = TxStartup(Port, NCGbyte)
    END IF
  NEXT Packet

  'done if empty packet 0
  IF EmptyFlag THEN
    CALL WriteMsg("Batch transfer completed", 1)
    TxyModem = %TRUE
    EXIT FUNCTION
  END IF

  'all done. send EOT up to 10 times
  IF NOT TxEOT(Port) THEN
    PRINT "EOT not acknowledged"
    TxyModem = %FALSE
    EXIT FUNCTION
  END IF

  CLOSE FileNbr
  CALL WriteMsg("Transfer completed", 1)
  TxyModem = %TRUE
  EXIT FUNCTION

TxyTrap:
  SELECT CASE ERR
    CASE 52
      Message$ = "Cannot open " + Filename$ + " for read"
      WriteMsg Message$, 1
    CASE ELSE
      PRINT "TX Error: "; "(ERROR$)" ; " ("; ERR; ")"
    END SELECT
    TxyModem = %FALSE
    EXIT FUNCTION

END FUNCTION

FUNCTION XmodemRx(BYVAL Port     AS INTEGER, _
                        Filename AS STRING,  _
                  BYVAL NCGbyte  AS BYTE)    PUBLIC

  IF FetchName(Filename$) THEN
    XmodemRx = RxyModem(Port, Filename$, NCGbyte, %FALSE)
  ELSE
    XmodemRx = %FALSE
  END IF

END FUNCTION

FUNCTION XmodemTx(BYVAL Port     AS INTEGER, _
                        Filename AS STRING,  _
                  BYVAL OneKflag AS INTEGER) PUBLIC

  IF FetchName(Filename$) THEN
    XmodemTx = TxyModem(Port, Filename$, OneKflag, %FALSE)
  ELSE
    XmodemTx = %FALSE
  END IF

END FUNCTION

FUNCTION YmodemRx(BYVAL Port     AS INTEGER, _
                        Filename AS STRING,  _
                  BYVAL NCGbyte  AS BYTE)    PUBLIC

  DIM AnyKey AS STRING

  YmodemRx = %TRUE
  DO
    AnyKey$ = INKEY$
    IF AnyKey$ <> "" THEN
      WriteMsg "Aborted by user", 1
      EXIT DO
    END IF
    WriteMsg "Ready for next file", 1
    Filename$ = ""
    IF NOT RxyModem(Port, Filename$, NCGbyte, %TRUE) THEN
      YmodemRx = %FALSE
      EXIT FUNCTION
    END IF
    'empty filename ?
    IF Filename$ = "" THEN
      EXIT FUNCTION
    END IF
  LOOP

END FUNCTION

FUNCTION YmodemTx(BYVAL Port     AS INTEGER,  _
                        Filename AS STRING,   _
                  BYVAL OneKflag AS INTEGER)  PUBLIC

  IF FetchName(Filename$) THEN
    YmodemTx = TxyModem(Port, Filename$, OneKflag, %TRUE)
    'send empty filename to terminate
    Filename$ = ""
    YmodemTx = TxyModem(Port, Filename$, OneKflag, %TRUE)
  ELSE
    YmodemTx = %FALSE
  END IF

END FUNCTION